home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / libs / vesatp11 / example / apfelves.pas next >
Encoding:
Pascal/Delphi Source File  |  1994-05-21  |  15.8 KB  |  755 lines
  1. {$N+,E+,G+,X+}
  2. PROGRAM ApfelVESA;
  3. {
  4.   (c) by Mark Stehr mkstehr@cip.informatik.uni-erlangen.de
  5. }
  6. Uses
  7.     VGraph,Crt,Dos,Printer;
  8.  
  9. CONST
  10.     modus             = V640x480x256;
  11.     MaximaleTiefe     = 255;
  12.  
  13.    Bild      : BOOLEAN = FALSE;
  14.    message  : STRING[35] = 'Bitte drücken Sie eine Taste ...';
  15.  
  16. TYPE
  17. {$ifopt N-}
  18.     Typ = Real;
  19. {$else}
  20.     Typ = Extended;
  21. {$endif}
  22.  
  23.     MandelType = RECORD
  24.         MaxTiefe             : WORD;
  25.         rlr,                                    { Left Side }
  26.         rrr,                                        { Right }
  27.         ior,                                        { Up }
  28.         iur                                        { Down }
  29.                              : REAL;
  30.         hh,mm,ss             : WORD;
  31.     END;
  32.  
  33.     MandelBrotHook  = FUNCTION(r,i :Typ):WORD;
  34.     AlgorithmusHook = PROCEDURE(dx,dy : TYP);
  35.  
  36. VAR
  37.     Mandel                    : MandelType;
  38.     FileName             : STRING;
  39.     taste                : CHAR;
  40.     hh2,mm2,ss2,sek100   : WORD;
  41.     hh1,mm1,ss1              : WORD;
  42.     mandelbrot                : MandelBrotHook;
  43.     algorithmus                : AlgorithmusHook;
  44.     i                            : WORD;
  45.     puffer                    : POINTER;
  46.    pal                        : PaletteType;
  47.    MaxColor                    : LONGINT;
  48.    MaxX,MaxY                : INTEGER;
  49.  
  50. PROCEDURE apfelmann; FORWARD;
  51.  
  52. {$F+}
  53. FUNCTION mandelbrot86(r,i :Typ):WORD;
  54. CONST
  55.     abbruchwert = 4;
  56.     MaxTiefe = MaximaleTiefe;
  57. VAR
  58.     x,y,x2,y2,xx     : Typ;
  59.     tiefe             : WORD;
  60. BEGIN
  61.     x := 0;
  62.     y := 0;
  63.     Tiefe:=0;
  64.  
  65.     REPEAT
  66.         x2 := x*x;
  67.         y2 := y*y;
  68.         xx := x2 - y2 + r;
  69.         y  := 2*x*y+ i;
  70.         x  := xx;
  71.         Inc(Tiefe);
  72.     UNTIL ((x2+y2)>abbruchwert) OR (Tiefe>=MaxTiefe);
  73.  
  74.     mandelbrot86:=Tiefe;
  75. END;
  76.  
  77. FUNCTION mandelbrot87(r,i :Typ):WORD;
  78. {
  79. Verwendung der Register:
  80.     ax = Funktionswert: Anzahl der Iterationen
  81.     bx = Abbruchwert
  82.     cx = Max. Anzahl der Iterationen
  83. }
  84. LABEL
  85.     fertig;
  86. CONST
  87.     abbruchwert : WORD = 4;                    { Wegen FICOMP }
  88.     MaxTiefe : WORD = MaximaleTiefe;
  89. {$ifopt G-}
  90. VAR
  91.     status : WORD;
  92. {$endif}
  93. BEGIN
  94.     asm
  95.  
  96.         finit                                            { Alles  neu }
  97.         fld tbyte ptr [r]                            { Lade r }
  98.         fld tbyte ptr [i]                            { Lade i }
  99.         fldz                                            { x^2 = 0 }
  100.         fldz                                            { y^2 = 0 }
  101.         fldz                                            { a = 0 }
  102.         fldz                                            { b = 0 }
  103.  
  104.         mov cx,[MaxTiefe]                            { cx = Max. Anzahl der Iterationen }
  105.         mov bx,[abbruchwert]                        { bx = Abbruchwert }
  106.         mov dx,0                                        { ax = Funktioneswert = 0 }
  107.  
  108. @repeat:
  109.  
  110.         fld st(1)                                    { Kopiere x }
  111.         fmul st(0),st(0)                            { x^2 }
  112.         fst st(4)                                    { Speicher x^2 }
  113.  
  114.         fld st(1)                                    { Kopiere y }
  115.         fmul st(0),st(0)                            { y^2 }
  116.         fst st(4)                                    { Speicher y^2 }
  117.         fsub                                            { x^2 - y^2 }
  118.  
  119.         fadd st(0),st(6)                            { x(n+1) = x^2 - x^2 + r }
  120.         fxch st(2)                                    { Austausch x <> x(n+1) }
  121.  
  122.         fmul                                       { x * y }
  123.         fadd st(0),st(0)                            { 2 * x * y }
  124.         fadd st(0),st(4)                            { y(n+1) = 2*x*y+i }
  125.  
  126.         inc dx                                        { Inc Tiefe }
  127.  
  128.         fld st(3)                                    { Kopier x^2 }
  129.         fadd st(0),st(3)                            { und addier y^2 }
  130.  
  131.         ficomp [abbruchwert]                        { Vergleiche }
  132. {$ifopt G+}
  133.         fstsw ax
  134. {$else}
  135.         fstsw [status]
  136.         mov ax,[status]                            { Speicher die Copro-Flags in AX }
  137. {$endif}
  138.         sahf                                            { mov flags,ax }
  139.         ja fertig                                    { Ja, fertig }
  140.  
  141.         loop @repeat                                { cx = cx -1 > 0 ? }
  142.  
  143. fertig:
  144.  
  145.         finit
  146.         mov @result,dx                                { Ergebnis nicht vergessen }
  147.     END;
  148. END;
  149. {$F-}
  150.  
  151.  
  152. PROCEDURE RestoreArea;
  153. CONST
  154.     VRam    : POINTER = Ptr($a000,0);
  155. BEGIN
  156.     SetActivePage(0);
  157.     Move(puffer^,VRam^,$ffff);
  158. END;
  159.  
  160. PROCEDURE SaveArea;
  161. CONST
  162.     VRam    : POINTER = Ptr($a000,0);
  163. BEGIN
  164.     SetActivePage(0);
  165.     Move(VRam^,puffer^,$ffff);
  166. END;
  167.  
  168. PROCEDURE achsenkreuz;
  169. VAR
  170.     i : WORD;
  171. BEGIN
  172.     SetColor(MaxColor DIV 2);
  173.     Rectangle(0,0,MaxX,MaxY);
  174.     WITH mandel DO BEGIN
  175.         i:=ROUND(ior/((ior-iur)/(MaxY+1)));
  176.         line(0,i,MaxX,i);
  177.         i:=MaxX-ROUND(rrr/((rrr-rlr)/(MaxX+1)));
  178.         line(i,0,i,MaxY);
  179.     END;
  180. END;
  181.  
  182. PROCEDURE ansehen;
  183. BEGIN
  184.     SetGraphMode(GetGraphMode);
  185.    SetPal(pal);
  186.     RestoreArea;
  187.     ReadKey;
  188.     RestoreCrtMode;
  189. END;
  190.  
  191.  
  192. PROCEDURE zoom;
  193. VAR
  194.     x1,y1,x2,y2,hoehe,breite: WORD;
  195.    dx,dy                    : TYP;
  196.    faktor                : TYP;
  197. BEGIN
  198.     SetGraphMode(GetGraphMode);
  199.    SetPal(pal);
  200.    RestoreArea;
  201.     SetWriteMode(XorPut);
  202.  
  203.    faktor := (MaxX+1) / (MaxY+1);
  204.     hoehe := MaxY DIV 4;
  205.     breite := Round(hoehe*faktor);
  206.     x1 := breite DIV 2;
  207.     y1 := hoehe DIV 2;
  208.    x2 := x1 + breite;
  209.    y2 := y1 + hoehe;
  210.    SetColor(MaxColor DIV 2);
  211.     REPEAT
  212.        breite := Round(hoehe*faktor);
  213.       x2 := x1 + breite;
  214.        y2 := y1 + hoehe;
  215.         Rectangle(x1,y1,x2,y2);
  216.         taste := ReadKey;
  217.         Rectangle(x1,y1,x2,y2);
  218.         CASE taste OF
  219.           #27 : BEGIN
  220.              SetWriteMode(CopyPut);
  221.             RestoreCrtMode;
  222.             Exit;
  223.          END;
  224.             #77 : IF x2 < MaxX THEN
  225.                 Inc(x1);                            { Right }
  226.             #75 : IF x1 > 0 THEN
  227.                 Dec(x1);                            { Left }
  228.             #72 : IF y1 > 0 THEN
  229.                 Dec(y1);                            { Up }
  230.             #80 : IF y2 < MaxY THEN
  231.                 Inc(y1);                            { Down }
  232.             '+' : BEGIN
  233.                 IF hoehe <= MaxY THEN BEGIN
  234.                     Inc(hoehe);
  235.                 END;
  236.             END;
  237.             '-' : BEGIN
  238.                 IF hoehe > 0 THEN BEGIN
  239.                     Dec(hoehe);
  240.                 END;
  241.             END;
  242.         END;
  243.     UNTIL taste = #13;
  244.  
  245.     WITH Mandel DO BEGIN
  246.         dx:=(rrr-rlr)/(MaxX+1);
  247.         dy:=(ior-iur)/(MaxY+1);
  248.         rlr := rlr + (x1*dx);
  249.         rrr := rrr - (MaxX-x2)*dx;
  250.         ior := ior - (y1*dy);
  251.         iur := iur + (MaxY-y2)*dy;
  252.     END;
  253.     SetWriteMode(NormalPut);
  254.    RestoreCrtMode;
  255.     apfelmann;
  256. END;
  257.  
  258. PROCEDURE effekt;
  259. VAR
  260.     OldPal    : PaletteType;
  261.    NewPal    : PaletteType;
  262. BEGIN
  263.     SetGraphMode(GetGraphMode);
  264.    SetPal(pal);
  265.     RestoreArea;
  266.    GetPal(OldPal);
  267.    NewPal := OldPal;
  268.     REPEAT
  269.         PushPal(NewPal);
  270.     UNTIL KeyPressed;
  271.     ReadKey;
  272.    SetPal(OldPal);
  273.     RestoreCrtMode;
  274. END;
  275.  
  276.  
  277. PROCEDURE eingabe;
  278. BEGIN
  279.     WITH Mandel DO BEGIN
  280.     Crt.Window(43,14,77,22);
  281.     TextBackGround(1);
  282.     ClrScr;
  283.     TextColor(LightCyan);
  284.     GotoXY(1,2);
  285.     WriteLN('  Bitte geben Sie die Werte ein.');
  286.     REPEAT
  287.         GotoXY(3,4);
  288.         Write('Max.Tiefe: ');
  289.         READLN(MaxTiefe);
  290.     UNTIL (MaxTiefe>0) AND (MaxTiefe<256);
  291.     REPEAT
  292.        GotoXY(3,5);
  293.        Write('Rlr : ');
  294.        READLN(rlr);
  295.     UNTIL (rlr>-3) AND (rlr<2.9);;
  296.     REPEAT
  297.        GotoXY(3,6);
  298.        Write('Rrr : ');
  299.        READLN(rrr);
  300.     UNTIL (rrr>rlr) AND (rrr<3);
  301.     REPEAT
  302.        GotoXY(3,7);
  303.        Write('Ior : ');
  304.        READLN(ior);
  305.     UNTIL (ior>-2) AND (ior<2);
  306.     REPEAT
  307.        GotoXY(3,8);
  308.        Write('Iur : ');
  309.        READLN(iur);
  310.      UNTIL (iur<ior) AND (iur<2);
  311.     END;
  312. END;
  313.  
  314.  
  315. PROCEDURE init_text;
  316. BEGIN
  317.     TextMode(Co80);
  318.    TextBackGround(Black);
  319.    TextColor(LightGray);
  320. END;
  321.  
  322.  
  323. PROCEDURE hardcopy_char(dichte:INTEGER);
  324.  
  325.    FUNCTION potenz(zeile:INTEGER):INTEGER;
  326.    BEGIN
  327.       CASE zeile OF
  328.          1:Potenz:=128;
  329.          2:Potenz:=64;
  330.          3:Potenz:=32;
  331.          4:Potenz:=16;
  332.          5:Potenz:=8;
  333.          6:Potenz:=4;
  334.          7:Potenz:=2;
  335.          8:Potenz:=1;
  336.       END;
  337.    END;
  338.  
  339. VAR
  340.    spalte,zeile,pixel       :INTEGER;
  341.    farbe1,farbe2,print      :INTEGER;
  342.    grafik                   :STRING[5];
  343.     an_zeilen,an_buch,zaehler:INTEGER;
  344.     i,j                                : WORD;
  345. BEGIN
  346.     SetGraphMode(GetGraphMode);
  347.    SetPal(pal);
  348.     RestoreArea;
  349.     CASE dichte OF
  350.       0:Pixel:=2;
  351.       1:Pixel:=2;
  352.       2:Pixel:=2;
  353.       3:Pixel:=1;
  354.    END;
  355.    an_zeilen:=((MaxY+1) DIV 11)*11;
  356.    an_buch:=(((MaxY+1) DIV 11)*Pixel)+32;
  357.    grafik:=Chr(27)+'&'+Chr(0)+Chr(33)+Chr(an_buch);   {Benutzer def. Zeichen}
  358.    Write(LST,Chr(7));                                 {Druckersignal}
  359.    Write(LST,Chr(27),Chr(64));                        {Drucker init.}
  360.    Write(LST,Chr(27),'A',Chr(8),Chr(27),'2');         {Zeilenabstand 8/72}
  361.    Write(LST,Chr(27),':',Chr(0),Chr(0),Chr(0));       {Kopieren ins Download}
  362.    Write(LST,Chr(27),'%1',Chr(0));                    {Benutzer def. Zeichensatz}
  363.    Write(LST,#27,'U',#1);                             {Unidirekt.}
  364.    IF Pixel=1 THEN Write(LST,#27,'P')
  365.               ELSE Write(LST,#27,'M');
  366.    spalte:=MaxX;
  367.    REPEAT
  368.       zaehler:=0;
  369.       Write(LST,Grafik);
  370.       FOR zeile:=0 TO (an_zeilen)-1 DO BEGIN
  371.         print:=0;
  372.         FOR j:=spalte DOWNTO (spalte-7) DO BEGIN
  373.               farbe1:=getpixel(j,zeile-1);
  374.               farbe2:=getpixel(j,zeile);
  375.            IF farbe1<>farbe2 THEN print:=print+potenz(spalte-j+1)
  376.                              ELSE BEGIN
  377.                                           farbe1:=getpixel(j+1,zeile);
  378.                                           farbe2:=getpixel(j,zeile);
  379.                                 IF farbe1<>farbe2 THEN print:=print+potenz(spalte-j+1);
  380.                            END;
  381.         END;   {von j}
  382.         FOR i:=1 TO Pixel DO BEGIN
  383.            IF (zaehler MOD 11)=0 THEN Write(LST,#139);
  384.            INC(zaehler,1);
  385.            Write(LST,Chr(print));
  386.         END;   {von i}
  387.       END;   {von zeile}
  388.       FOR i:=33 TO an_buch DO
  389.          Write(LST,Chr(i));
  390.       Write(LST,#13,#10);
  391.       DEC(spalte,8);
  392.    UNTIL spalte<=0;
  393.    Write(LST,#13,#10,#7,#7,#7);
  394. END;
  395.  
  396.  
  397. PROCEDURE laden;
  398. VAR
  399.     f           : FILE;
  400. BEGIN
  401.     Crt.Window(3,25,77,25);
  402.     TextBackGround(Blue);
  403.     ClrScr;
  404.     TextColor(LightCyan);
  405.     Write(' Filename ?: ');
  406.     READLN(FileName);
  407.  
  408.     SetGraphMode(GetGraphMode);
  409.    SetPal(pal);
  410.  
  411.     LoadPCX(0,0,filename+'.pcx');
  412.  
  413. {$I-}
  414.     Assign(f,filename+'.dat');
  415.     Reset(f,1);
  416.     BlockRead(f,mandel,SizeOf(mandel));
  417.     Close(f);
  418. {$I+}
  419.     IF IOResult=0 THEN BEGIN
  420.         SaveArea;
  421.       bild := TRUE;
  422.    END;
  423.  
  424.     RestoreCrtMode;
  425. END;
  426.  
  427. PROCEDURE speichern;
  428. VAR
  429.     f      : FILE;
  430. BEGIN
  431.     Crt.Window(3,25,77,25);
  432.     TextBackGround(Blue);
  433.     ClrScr;
  434.     TextColor(LightCyan);
  435.    Write(' Filename ?: ');
  436.     READLN(FileName);
  437.  
  438.     SetGraphMode(GetGraphMode);
  439.    SetPal(pal);
  440.     RestoreArea;
  441.  
  442.     SavePCX(0,0,MaxX,MaxY,filename+'.pcx');
  443.  
  444. {$I-}
  445.     Assign(f,FileName+'.dat');
  446.     ReWrite(f,1);
  447.     BlockWrite(f,mandel,SizeOf(mandel));
  448.     Close(f);
  449. {$I+}
  450.  
  451.     RestoreCrtMode;
  452. END;
  453.  
  454.  
  455. PROCEDURE stopuhr(stop : BOOLEAN);
  456. BEGIN
  457.    IF Not Stop THEN BEGIN
  458.         GetTime(hh1,mm1,ss1,sek100);
  459.       stop:=TRUE;
  460.    END
  461.    ELSE BEGIN
  462.         GetTime(hh2,mm2,ss2,sek100);
  463.         IF ss1>ss2 THEN BEGIN
  464.             mandel.ss:=60-ss1+ss2;
  465.             mm1:=SUCC(mm1);
  466.         END
  467.         ELSE
  468.             mandel.ss:=ss2-ss1;
  469.         IF mm1>mm2 THEN BEGIN
  470.             mandel.mm:=60-mm1+mm2;
  471.             hh1:=SUCC(hh1);
  472.         END
  473.         ELSE
  474.             mandel.mm:=mm2-mm1;
  475.         mandel.hh:=hh2-hh1;
  476.    END;
  477. END;
  478.  
  479. {---------------------------------------------------------------------------}
  480. {$F+}
  481. PROCEDURE algorithmus1(dx,dy : TYP);
  482. VAR
  483.     x,y,Tiefe2,Tiefe1 : WORD;
  484.     xc,yc             : Typ;
  485.  
  486.     FUNCTION zyklodentest(xc,yc:Typ):INTEGER;
  487.     VAR
  488.         r,s,x,y,x2,y2 :Typ;
  489.     BEGIN
  490.         y2:=yc*yc;
  491.         x2:=xc+1.0;
  492.         IF (xc>-0.75) THEN BEGIN
  493.             r:=xc*xc+y2;
  494.             s:=SQRT(r-0.5*xc+0.0625);
  495.             IF ((16.0*r*s)>(5.0*s-4.0*xc+1.0)) THEN
  496.                 Zyklodentest:=mandelbrot(xc,yc)
  497.             ELSE
  498.                 Zyklodentest:=Mandel.MaxTiefe;
  499.         END
  500.         ELSE
  501.             IF((x2*x2+y2)>0.0625) THEN
  502.                 Zyklodentest:=mandelbrot(xc,yc)
  503.             ELSE
  504.                 Zyklodentest:=Mandel.MaxTiefe;
  505.     END;
  506.  
  507. BEGIN
  508.     WITH mandel DO BEGIN
  509.  
  510.     yc:=ior;
  511.     y:=0;
  512.     REPEAT
  513.  
  514.         xc:=rlr;
  515.         x:=0;
  516.         Tiefe1 := Zyklodentest(xc,yc);
  517.         putpixel(x,y,Tiefe1);
  518.         REPEAT
  519.             xc := xc + dx +dx;
  520.             Inc(x,2);
  521.             Tiefe2:=Zyklodentest(xc,yc);
  522.             putpixel(x,y,Tiefe2);
  523.             IF (Tiefe1<>Tiefe2) THEN
  524.                 Tiefe1:=Zyklodentest(xc-dx,yc);
  525.             putpixel(x-1,y,Tiefe1);
  526.             Tiefe1 := Tiefe2;
  527.         UNTIL (x>=MaxX);
  528.  
  529.         xc:=rlr;
  530.         FOR x:=0 TO MaxX DO BEGIN
  531.             Tiefe1:=getpixel(x,y);
  532.             Tiefe2:=getpixel(x,y+2);
  533.             IF (Tiefe1=Tiefe2) THEN
  534.                 putpixel(x,y+1,Tiefe1)
  535.             ELSE
  536.                 putpixel(x,y+1,Zyklodentest(xc,yc-dy));
  537.             xc:=xc+dx;
  538.         END;
  539.  
  540.         yc:=yc-dy-dy;
  541.         INC(y,2);
  542.     UNTIL (y>=MaxY) OR KeyPressed;                                { !!! }
  543.     END;
  544. END;
  545.  
  546. PROCEDURE algorithmus2(dx,dy : TYP);
  547.  
  548.     Procedure Recurse (X1,Y1,X2,Y2 : WORD);
  549.     Var
  550.         CX,CY : Word;
  551.         c        : WORD;
  552.     Label
  553.         DontFillIt;
  554.     Begin
  555.         WITH mandel DO BEGIN
  556.         C := mandelbrot(rlr + X1*dx,ior - Y1*dy);
  557.         If C<> mandelbrot (rlr + X1*dx,ior - Y2*dy) Then
  558.             GoTo DontFillIt;
  559.  
  560.         For CX := X1+1 To X2 Do Begin
  561.             If (C<> mandelbrot(rlr + CX*dx,ior - Y1*dy)) Or (C<> mandelbrot (rlr + CX*dx,ior - Y2*dy)) Then
  562.                 GoTo DontFillIt;
  563.         End;
  564.         For CY := Y1 To Y2 Do Begin
  565.             If (C<> mandelbrot(rlr + X1*dx,ior - CY*dy)) Or (C<> mandelbrot (rlr + X2*dx,ior - CY*dy)) Then
  566.                 GoTo DontFillIt;
  567.         End;
  568.       SetFillStyle(SolidFill,c);
  569.         FillImage(X1+1,Y1+1, X2-1,Y2-1);
  570.         Exit;
  571.  
  572. DontFillit:
  573.         If (X2-X1) > (Y2-Y1) Then Begin
  574.             CX := (X2-X1) Div 2 +X1;
  575.             For CY := Y1+1 To Y2-1 Do
  576.                 PutPixel (CX,CY, mandelbrot(rlr + CX*dx,ior - CY*dy));
  577.             If (CX-X1>1) Then
  578.                 Recurse (X1,Y1,CX,Y2);
  579.             If (X2-CX>1) Then
  580.                 Recurse (CX,Y1,X2,Y2);
  581.         End
  582.         Else Begin
  583.             CY := (Y2-Y1) Div 2 +Y1;
  584.             For CX := X1+1 To X2-1 Do
  585.                 PutPixel (CX,CY, mandelbrot(rlr + CX*dx,ior - CY*dy));
  586.             If (CY-Y1>1) Then
  587.                 Recurse (X1,Y1,X2,CY);
  588.             If (Y2-CY>1) Then
  589.                 Recurse (X1,CY,X2,Y2);
  590.         END;
  591.         End;
  592.     End;
  593.  
  594. Begin
  595.     Recurse (0         ,0,MaxX Div 2+1,MaxY);
  596.     Recurse (MaxX Div 2,0,MaxX        ,MaxY);
  597. End;
  598. {$F-}
  599.  
  600. PROCEDURE apfelmann;
  601. VAR
  602.     dx,dy    : TYP;
  603. BEGIN
  604.     SetGraphMode(GetGraphMode);
  605.    SetPal(pal);
  606.     achsenkreuz;
  607.     WITH Mandel DO BEGIN
  608.         dx:=(rrr-rlr)/(MaxX+1);
  609.         dy:=(ior-iur)/(MaxY+1);
  610.     END;
  611.  
  612.     stopuhr(false);
  613.     algorithmus(dx,dy);
  614.     stopuhr(true);
  615.     Beep;
  616.     SavePCX(0,0,MaxX,MaxY,'dummy.pcx');
  617.     ReadKey;
  618.     SaveArea;
  619.    RestoreCrtMode;
  620.    bild:=TRUE;
  621. END;
  622.  
  623. {---------------------------------------------------------------------------}
  624. PROCEDURE menu;
  625. VAR
  626.     ende    : BOOLEAN;
  627. BEGIN
  628.    ende:=FALSE;
  629.     REPEAT
  630.         TextBackGround(Black);
  631.         Crt.Window(1,1,80,25);
  632.       ClrScr;
  633.         Crt.Window(45,5,78,12);
  634.        TextBackGround(LightGray);
  635.        ClrScr;
  636.         Crt.Window(43,3,77,11);
  637.        TextBackGround(Blue);
  638.        ClrScr;
  639.        TextColor(LightCyan);
  640.        GotoXY(1,3);
  641.          WriteLN('      Apfelmännchen VESA 3.0');
  642.          WriteLN;
  643.          WriteLN('        (c) by Mark Stehr');
  644.          WriteLN('          91056 Erlangen');
  645.          WriteLN;
  646.         Crt.Window(45,16,78,23);
  647.          TextBackGround(LightGray);
  648.          ClrScr;
  649.         Crt.Window(43,14,77,22);
  650.          TextBackGround(1);
  651.          ClrScr;
  652.          TextColor(LightCyan);
  653.          GotoXY(1,2);
  654.          WriteLN('  Filename : ',FileName);
  655.          WITH Mandel DO BEGIN
  656.             WriteLN('  Dauer    : ',hh:2,':',mm:2,':',ss:2);
  657.             WriteLN('  Max.Tiefe: ',MaxTiefe);
  658.             WriteLN('  Rlr : ',rlr:2:20);
  659.             WriteLN('  Rrr : ',rrr:2:20);
  660.             WriteLN('  Ior : ',ior:2:20);
  661.             WriteLN('  Iur : ',iur:2:20);
  662.          END;
  663.         Crt.Window(3,25,77,25);
  664.          TextBackGround(Blue);
  665.          ClrScr;
  666.          TextColor(LightCyan);
  667.          GotoXY(2,1);
  668.          Write(message);
  669.         Crt.Window(5,5,24,23);
  670.          TextBackGround(LightGray);
  671.          ClrScr;
  672.         Crt.Window(3,3,23,22);
  673.          TextBackGround(Blue);
  674.          TextColor(LightCyan);
  675.          ClrScr;
  676.          GotoXY(2,2);Write('W');
  677.          GotoXY(2,4);Write('B');
  678.          GotoXY(2,6);Write('A');
  679.          GotoXY(2,8);Write('S');
  680.          GotoXY(2,10);Write('L');
  681.          GotoXY(2,12);Write('D');
  682.          GotoXY(2,14);Write('Z');
  683.          GotoXY(2,16);Write('E');
  684.  
  685.          GotoXY(2,18);Write('Esc ');
  686.          TextColor(14);
  687.          GotoXY(4,2);Write('erte eingeben');
  688.          GotoXY(4,4);Write('erechnen');
  689.          GotoXY(4,6);Write('nsehen');
  690.          GotoXY(4,8);Write('peichern');
  691.          GotoXY(4,10);Write('aden');
  692.          GotoXY(4,12);Write('rucken');
  693.          GotoXY(4,14);Write('oom');
  694.          GotoXY(4,16);Write('ffekt');
  695.          GotoXY(6,18);Write('Ende');
  696.         Crt.Window(1,1,80,25);
  697.         REPEAT
  698.             GetTime(hh2,mm2,ss2,sek100);
  699.             GotoXY(66,25);
  700.             IF (hh2<10) THEN Write('0');
  701.             Write(hh2,':');
  702.             IF (mm2<10) THEN Write('0');
  703.             Write(mm2,':');
  704.             IF (ss2<10) THEN Write('0');
  705.             Write(ss2);
  706.         UNTIL KeyPressed;
  707.         taste:=ReadKey;
  708.         CASE UpCase(taste) OF
  709.             'W':eingabe;
  710.             'B':apfelmann;
  711.             'A':IF bild THEN ansehen;
  712.             'S':IF bild THEN Speichern;
  713.             'L':laden;
  714.             'D':IF bild THEN hardcopy_char(1);
  715.             'Z':IF bild THEN zoom;
  716.             'E':IF bild THEN effekt;
  717.             #27:ende:=TRUE;
  718.         END;
  719.     UNTIL ende;
  720. END;
  721.  
  722. BEGIN
  723.     GetMem(puffer,$FFFF);
  724.  
  725.     IF test8087 <> 0 THEN
  726.         mandelbrot := mandelbrot87
  727.     ELSE
  728.         mandelbrot := mandelbrot86;
  729.  
  730.     Algorithmus := algorithmus1;
  731.  
  732.    InitVesa(modus);
  733.    MaxX := GetMaxX;
  734.    MaxY := GetMaxY;
  735.    MaxColor := GetMaxColor;
  736.    NewPal(pal);
  737.    RestoreCrtMode;
  738.  
  739.     init_text;
  740.     FileName:=#0;
  741.     WITH Mandel DO BEGIN
  742.         hh:=0;
  743.         mm:=0;
  744.         ss:=0;
  745.         rrr:=1.0;
  746.         rlr:=-2.0;
  747.         ior:=1.15;
  748.         iur:=-1.15;
  749.         MaxTiefe:=MaximaleTiefe;
  750.     END;
  751.     menu;
  752.    CloseVesa;
  753.  
  754.     FreeMem(puffer,$FFFF);
  755. END.